home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / iconv8_s.arc / ICONX.ARC / LMISC.C < prev    next >
Encoding:
C/C++ Source or Header  |  1990-03-28  |  13.9 KB  |  579 lines
  1. /*
  2.  * File: lmisc.c
  3.  *  Contents: create, keywd, limit, llist
  4.  */
  5.  
  6. #include "..\h\config.h"
  7. #include "..\h\rt.h"
  8. #include "rproto.h"
  9. #include "..\h\keyword.h"
  10. #include "..\h\version.h"
  11.  
  12.  
  13.  
  14. /*
  15.  * create - return an entry block for a co-expression.
  16.  */
  17.  
  18. OpBlock(create,1,"create",0)
  19.  
  20. Ocreate(entryp, cargp)
  21. word *entryp;
  22. register dptr cargp;
  23.    {
  24.  
  25. #ifdef Coexpr
  26.    register struct b_coexpr *sblkp;
  27.    register struct b_refresh *rblkp;
  28.    register dptr dp, ndp, dsp;
  29.    register word *newsp;
  30.    int na, nl, i;
  31.    struct b_proc *cproc;
  32.  
  33.    /*
  34.     * Get a new co-expression stack and initialize.
  35.     */
  36.    if ((sblkp = alccoexp()) == NULL) 
  37.       RunErr(0, NULL);
  38.  
  39.    /*
  40.     * Icon stack starts at word after co-expression stack block.  C stack
  41.     *  starts at end of stack region on machines with down-growing C stacks
  42.     *  and somewhere in the middle of the region.
  43.     *
  44.     * The C stack is aligned on a doubleword boundary.    For upgrowing
  45.     *  stacks, the C stack starts in the middle of the stack portion
  46.     *  of the static block.  For downgrowing stacks, the C stack starts
  47.     *  at the end of the static block.
  48.     */
  49.    newsp = (word *)((char *)sblkp + sizeof(struct b_coexpr));
  50.  
  51. #ifdef UpStack
  52.    sblkp->cstate[0] =
  53.       ((word)((char *)sblkp + (stksize - sizeof(*sblkp))/2)
  54.        &~(WordSize*StackAlign-1));
  55. #else                    /* UpStack */
  56.    sblkp->cstate[0] =
  57.     ((word)((char *)sblkp + stksize - WordSize)&~(WordSize*StackAlign-1));
  58. #endif                    /* UpStack */
  59.  
  60. #ifdef CoProcesses
  61.    sblkp->cstate[1] = 0;
  62. #endif
  63.  
  64.  
  65.    sblkp->es_argp = (dptr )newsp;
  66.    /*
  67.     * Calculate number of arguments and number of local variables.
  68.     *  na is nargs + 1 to include Arg0.
  69.     */
  70.    na = pfp->pf_nargs + 1;
  71.    cproc = (struct b_proc *)BlkLoc(argp[0]);
  72.    nl = (int)cproc->ndynam;
  73.  
  74.    /*
  75.     * Get a refresh block for the new co-expression.
  76.     */
  77.    if (blkreq((word)sizeof(struct b_refresh) +
  78.          (na + nl) * sizeof(struct descrip)) == Error) 
  79.       RunErr(0, NULL);
  80.    rblkp = alcrefresh(entryp, na, nl);
  81.    sblkp->freshblk.dword = D_Refresh;
  82.    BlkLoc(sblkp->freshblk) = (union block *) rblkp;
  83.  
  84.    /*
  85.     * Copy current procedure frame marker into refresh block.
  86.     */
  87.    rblkp->pfmkr = *pfp;
  88.    rblkp->pfmkr.pf_pfp = 0;
  89.  
  90.    /*
  91.     * Copy arguments into refresh block and onto new stack.
  92.     */
  93.    dp = &argp[0];
  94.    ndp = &rblkp->elems[0];
  95.    dsp = (dptr)newsp;
  96.    for (i = 1; i <= na; i++) {
  97.       *dsp++ = *dp;
  98.       *ndp++ = *dp++;
  99.       }
  100.  
  101.    /*
  102.     * Copy procedure frame to new stack and point dsp to word after frame.
  103.     */
  104.    *((struct pf_marker *)dsp) = *pfp;
  105.    sblkp->es_pfp = (struct pf_marker *)dsp;
  106.    sblkp->es_pfp->pf_pfp = 0;
  107.    dsp = (dptr)((word *)dsp + Vwsizeof(*pfp));
  108.    sblkp->es_ipc.opnd = entryp;
  109.    sblkp->es_gfp = 0;
  110.    sblkp->es_efp = 0;
  111.    sblkp->es_ilevel = 0;
  112.    sblkp->tvalloc = NULL;
  113.  
  114.    /*
  115.     * Copy locals to new stack and refresh block.
  116.     */
  117.    dp = &(pfp->pf_locals)[0];
  118.    for (i = 1; i <= nl; i++) {
  119.       *dsp++ = *dp;
  120.       *ndp++ = *dp++;
  121.       }
  122.    /*
  123.     * Push two null descriptors on the stack.
  124.     */
  125.    *dsp++ = nulldesc;
  126.    *dsp++ = nulldesc;
  127.  
  128.    sblkp->es_sp = (word *)dsp - 1;
  129.  
  130.    /*
  131.     * Return the new co-expression.
  132.     */
  133.    Arg0.dword = D_Coexpr;
  134.    BlkLoc(Arg0) = (union block *) sblkp;
  135.    Return;
  136. #else                    /* Coexpr */
  137.    RunErr(-401, NULL);
  138. #endif                    /* Coexpr */
  139.  
  140.    }
  141.  
  142. /*
  143.  * keywd - process keyword.
  144.  */
  145.  
  146. char *feattab[] = {
  147. #if AMIGA
  148.    "Amiga",
  149. #endif                    /* AMIGA */
  150. #if ATARI_ST
  151.    "Atari ST",
  152. #endif                    /* ATARI_ST */
  153. #if VM
  154.    "CMS",
  155. #endif                    /* VM */
  156. #if HIGHC_386
  157.    "MS-DOS/386",
  158. #endif                    /* HIGHC_386 */
  159. #if MACINTOSH
  160.    "Macintosh",
  161. #endif                    /* MACINTOSH */
  162. #if MSDOS
  163.    "MS-DOS",
  164. #endif                    /* MSDOS */
  165. #if MVS
  166.    "MVS",
  167. #endif                    /* MVS */
  168. #if OS2
  169.    "OS/2",
  170. #endif                    /* OS2 */
  171. #if PORT
  172.    "PORT",
  173. #endif                    /* PORT */
  174. #if UNIX
  175.    "UNIX",
  176. #endif                    /* VM */
  177. #if VMS
  178.    "VMS",
  179. #endif                    /* VMS */
  180. #if !EBCDIC
  181.    "ASCII",
  182. #else                    /* EBCDIC */
  183.    "EBCDIC",
  184. #endif                    /* EBCDIC */
  185. #ifdef IconCalling
  186.    "calling to Icon",
  187. #endif                    /* IconCalling */
  188. #ifdef Coexpr
  189.    "co-expressions",
  190. #endif                    /* Coexpr */
  191. #ifdef Header
  192.    "direct execution",
  193. #endif                    /* Header */
  194. #ifdef EnvVars
  195.    "environment variables",
  196. #endif                    /* EnvVars */
  197. #ifdef TraceBack
  198.    "error trace back",
  199. #endif                    /* TraceBack */
  200. #ifdef EvalTrace
  201.    "evaluation tracing",
  202. #endif                    /* EvalTrace */
  203. #ifdef ExecImages
  204.    "executable images",
  205. #endif                    /* ExecImages */
  206. #ifndef FixedRegions
  207.    "expandable regions",
  208. #endif                    /* FixedRegions */
  209. #ifdef ExternalFunctions
  210.    "external functions",
  211. #endif                    /* ExternalFunctions */
  212. #ifdef FixedRegions
  213.    "fixed regions",
  214. #endif                    /* FixedRegions */
  215. #ifdef KeyboardFncs
  216.    "keyboard functions",
  217. #endif                    /* KeyboardFncs */
  218. #ifdef LargeInts
  219.    "large integers",
  220. #endif                    /* LargeInts */
  221. #ifdef MathFncs
  222.    "math functions",
  223. #endif                    /* MathFncs */
  224. #ifdef MemMon
  225.    "memory monitoring",
  226. #endif                    /* MEMMON */
  227. #ifdef Pipes
  228.    "pipes",
  229. #endif                    /* Pipes */
  230. #ifdef RecordIO
  231.    "record I/O",
  232. #endif                    /* RecordIO */
  233. #ifdef StrInvoke
  234.    "string invocation",
  235. #endif                    /* StrInvoke */
  236. #ifdef SystemFnc
  237.    "system function",
  238. #endif                    /* SystemFnc */
  239. #ifdef DosFncs
  240.    "MS-DOS extensions",
  241. #endif                    /* DosFncs */
  242.    ""
  243.    };
  244.  
  245. LibDcl(keywd,0,"&keywd")
  246.    {
  247.    register int hour;
  248.    register word i;
  249.    register char *merid;
  250.    char **p;
  251.    char sbuf[MaxCvtLen];
  252.    extern word coll_stat, coll_str, coll_blk, coll_tot;
  253.    long runtim;
  254.    struct cal_time ct;
  255.  
  256. #if MACINTOSH && MPW
  257. /* #pragma unused(nargs) */
  258. #endif                    /* MACINTOSH && MPW */
  259.  
  260.    /*
  261.     * This is just plug and chug code.    For whatever keyword is desired,
  262.     *  the appropriate value is dug out of the system and made into
  263.     *  a suitable Icon value.
  264.     *
  265.     * A few special cases are worth noting:
  266.     *  &pos, &random, &trace - built-in trapped variables are returned
  267.     */
  268.    switch ((int)IntVal(Arg0)) {
  269.       case K_ASCII:
  270.          Arg0.dword = D_Cset;
  271.          BlkLoc(Arg0) = (union block *) &k_ascii;
  272.          break;
  273.       case K_CLOCK:
  274.          if (strreq((word)8) == Error) 
  275.             RunErr(0, NULL);
  276.          getitime(&ct);
  277.          sprintf(sbuf,"%02d:%02d:%02d", ct.hour, ct.minute, ct.second);
  278.          StrLen(Arg0) = 8;
  279.          StrLoc(Arg0) = alcstr(sbuf,(word)8);
  280.          break;
  281.       case K_COLLECTIONS:
  282.          MakeInt(coll_tot, &Arg0);
  283.          Suspend;
  284.          MakeInt(coll_stat, &Arg0);
  285.          Suspend;
  286.          MakeInt(coll_str, &Arg0);
  287.          Suspend;
  288.          MakeInt(coll_blk, &Arg0);
  289.          Return;
  290.  
  291.  
  292.       case K_CSET:
  293.          Arg0.dword = D_Cset;
  294.          BlkLoc(Arg0) = (union block *) &k_cset;
  295.          break;
  296.       case K_CURRENT:
  297.          Arg0 = k_current;
  298.          break;
  299.       case K_DATE:
  300.          if (strreq((word)10) == Error) 
  301.             RunErr(0, NULL);
  302.          getitime(&ct);
  303.          sprintf(sbuf, "%04d/%02d/%02d", ct.year, ct.month_no, ct.mday);
  304.          StrLen(Arg0) = 10;
  305.          StrLoc(Arg0) = alcstr(sbuf,(word)10);
  306.          break;
  307.       case K_DATELINE:
  308.          getitime(&ct);
  309.          if ((hour = ct.hour) >= 12) {
  310.             merid = "pm";
  311.             if (hour > 12)
  312.                hour -= 12;
  313.             }
  314.          else {
  315.             merid = "am";
  316.             if (hour < 1)
  317.                hour += 12;
  318.             }
  319.          sprintf(sbuf, "%s, %s %d, %d  %d:%02d %s", ct.wday, ct.month_nm,
  320.             ct.mday, ct.year, hour, ct.minute, merid);
  321.          if (strreq(i = strlen(sbuf)) == Error) 
  322.             RunErr(0, NULL);
  323.          StrLen(Arg0) = i;
  324.          StrLoc(Arg0) = alcstr(sbuf, i);
  325.          break;
  326.       case K_DIGITS:
  327.          Arg0.dword = D_Cset;
  328.          BlkLoc(Arg0) = (union block *)&k_digits;
  329.          break;
  330.  
  331.  
  332.       case K_ERROR:
  333.          Arg0.dword = D_Tvkywd;
  334.          BlkLoc(Arg0) = (union block *)&tvky_err;
  335.          break;
  336.  
  337.       case K_ERRORNUMBER:
  338.          if (k_errornumber == 0)
  339.             Fail;
  340.          MakeInt((k_errornumber > 0 ? k_errornumber : -k_errornumber), &Arg0);
  341.          break;
  342.       case K_ERRORTEXT:
  343.          if (k_errornumber == 0)
  344.             Fail;
  345.          StrLoc(Arg0) = k_errortext;
  346.          StrLen(Arg0) = strlen(k_errortext);
  347.          break;
  348.       case K_ERRORVALUE:
  349.          if (k_errornumber <= 0)
  350.             Fail;
  351.          Arg0 = k_errorvalue;
  352.          break;
  353.       case K_ERROUT:
  354.          Arg0.dword = D_File;
  355.          BlkLoc(Arg0) = (union block *)&k_errout;
  356.          break;
  357.       case K_FEATURES:
  358.          p = feattab;
  359.          for(;;) {
  360.             StrLen(Arg0) = strlen(*p);
  361.             if (StrLen(Arg0) == 0)
  362.                Fail;
  363.             StrLoc(Arg0) = *p;
  364.             Suspend;
  365.             p++;
  366.             }
  367.       case K_FILE:
  368.          StrLoc(Arg0) = findfile(ipc.opnd);
  369.          StrLen(Arg0) = strlen(StrLoc(Arg0));
  370.          break;
  371.  
  372.  
  373.       case K_HOST:
  374.          iconhost(sbuf);
  375.          if (strreq(i = strlen(sbuf)) == Error) 
  376.             RunErr(0, NULL);
  377.          StrLen(Arg0) = i;
  378.          StrLoc(Arg0) = alcstr(sbuf, i);
  379.          break;
  380.       case K_INPUT:
  381.          Arg0.dword = D_File;
  382.          BlkLoc(Arg0) = (union block *)&k_input;
  383.          break;
  384.       case K_LCASE:
  385.          Arg0.dword = D_Cset;
  386.          BlkLoc(Arg0) = (union block *)&k_lcase;
  387.          break;
  388.       case K_LETTERS:
  389.          Arg0.dword = D_Cset;
  390.          BlkLoc(Arg0) = (union block *)&k_letters;
  391.          break;
  392.       case K_LEVEL:
  393.          MakeInt(k_level, &Arg0);
  394.          break;
  395.       case K_LINE:
  396.          MakeInt(findline(ipc.opnd), &Arg0);
  397.          break;
  398.       case K_MAIN:
  399.          Arg0 = k_main;
  400.          break;
  401.       case K_OUTPUT:
  402.          Arg0.dword = D_File;
  403.          BlkLoc(Arg0) = (union block *)&k_output;
  404.          break;
  405.       case K_POS:
  406.          Arg0.dword = D_Tvkywd;
  407.          BlkLoc(Arg0) = (union block *) &tvky_pos;
  408.          break;
  409.       case K_RANDOM:
  410.          Arg0.dword = D_Tvkywd;
  411.          BlkLoc(Arg0) = (union block *) &tvky_ran;
  412.          break;
  413.       case K_REGIONS:
  414.  
  415. #ifdef FixedRegions
  416.          Arg0 = zerodesc;
  417. #else                    /* FixedRegions */
  418.          MakeInt(DiffPtrs(statend,statbase) - mstksize, &Arg0);
  419. #endif                    /* FixedRegions */
  420.  
  421.          Suspend;
  422.          MakeInt(DiffPtrs(strend,strbase), &Arg0);
  423.          Suspend;
  424.          MakeInt(DiffPtrs(blkend,blkbase), &Arg0);
  425.          Return;
  426.  
  427.       case K_SOURCE:
  428.  
  429. #ifndef Coexpr
  430.          Arg(0) = k_main;
  431. #else                    /* Coexpr */
  432.       Arg0.dword = D_Coexpr;
  433.       BlkLoc(Arg0) =
  434.             (union block *)topact((struct b_coexpr *)BlkLoc(k_current));
  435. #endif                    /* Coexpr */
  436.  
  437.          break;
  438.       case K_STORAGE:
  439.  
  440. #ifdef FixedRegions
  441.          Arg0 = zerodesc;
  442. #else                    /* FixedRegions */
  443.          MakeInt(DiffPtrs(statfree,statbase) - mstksize, &Arg0);
  444. #endif                    /* FixedRegions */
  445.  
  446.          Suspend;
  447.          MakeInt(DiffPtrs(strfree,strbase), &Arg0);
  448.          Suspend;
  449.          MakeInt(DiffPtrs(blkfree,blkbase), &Arg0);
  450.          Return;
  451.       case K_SUBJECT:
  452.          Arg0.dword = D_Tvkywd;
  453.          BlkLoc(Arg0) = (union block *) &tvky_sub;
  454.          break;
  455.       case K_TIME:
  456.          runtim = millisec();
  457.          MakeInt(runtim, &Arg0);
  458.          break;
  459.       case K_TRACE:
  460.          Arg0.dword = D_Tvkywd;
  461.          BlkLoc(Arg0) = (union block *)&tvky_trc;
  462.          break;
  463.       case K_UCASE:
  464.          Arg0.dword = D_Cset;
  465.          BlkLoc(Arg0) = (union block *)&k_ucase;
  466.          break;
  467.       case K_VERSION:
  468.          if (strreq(i = strlen(Version)) == Error) 
  469.             RunErr(0, NULL);
  470.          StrLen(Arg0) = i;
  471.          StrLoc(Arg0) = Version;
  472.          break;
  473.       default:
  474.          syserr("keyword: unknown keyword type.");
  475.       }
  476.    Return;
  477.    }
  478.  
  479.  
  480. /*
  481.  * limit - explicit limitation initialization.
  482.  */
  483.  
  484.  
  485. #ifdef WATERLOO_C_V3_0
  486. struct b_iproc Blimit = {
  487.     T_Proc,
  488.     Vsizeof(struct b_proc),
  489.     Olimit,
  490.     2,
  491.     -1,
  492.     0,
  493.     0,
  494.     {sizeof(BackSlash)-1,BackSlash}}; Olimit(nargs,cargp,sptr) register dptr cargp;
  495. #else                    /* WATERLOO_C_V3_0 */
  496. LibDcl(limit,2,BackSlash)
  497. #endif                    /* WATERLOO_C_V3_0 */
  498.  
  499.    {
  500.  
  501. #if MACINTOSH
  502. #if MPW
  503. /* #pragma unused(nargs) */
  504. #endif                    /* MPW */
  505. #endif                    /* MACINTOSH */
  506.  
  507.    /*
  508.     * The limit is both passed and returned in Arg0.  The limit must
  509.     *  be an integer.  If the limit is 0, the expression being evaluated
  510.     *  fails.  If the limit is < 0, it is an error.  Note that the
  511.     *  result produced by limit is ultimately picked up by the lsusp
  512.     *  function.
  513.     */
  514.    if (DeRef(Arg0) == Error) 
  515.       RunErr(0, NULL);
  516.  
  517.    switch (cvint(&Arg0)) {
  518.  
  519.       case T_Integer:
  520.          break;
  521.  
  522.       default:
  523.          RunErr(101, &Arg0);
  524.       }
  525.  
  526.    if (IntVal(Arg0) < 0) 
  527.       RunErr(205, &Arg0);
  528.    if (IntVal(Arg0) == 0)
  529.       Fail;
  530.    Return;
  531.    }
  532.  
  533.  
  534. /*
  535.  * [ ... ] - create an explicitly specified list.
  536.  */
  537.  
  538. LibDcl(llist,-1,"[...]")
  539.    {
  540.    register word i;
  541.    register struct b_list *hp;
  542.    register struct b_lelem *bp;
  543.    word nslots;
  544.  
  545.    nslots = nargs;
  546.    if (nslots == 0)
  547.       nslots = MinListSlots;
  548.  
  549.    if (blkreq((word)sizeof(struct b_list) + sizeof(struct b_lelem) +
  550.          nslots * sizeof(struct descrip)) == Error) 
  551.       RunErr(0, NULL);
  552.  
  553.    /*
  554.     * Allocate the list and a list block.
  555.     */
  556.    hp = alclist((word)nargs);
  557.    bp = alclstb(nslots, (word)0, (word)nargs);
  558.  
  559.    /*
  560.     * Make the list block just allocated into the first and last blocks
  561.     *  for the list.
  562.     */
  563.    hp->listhead = hp->listtail = (union block *)bp;
  564.    /*
  565.     * Dereference each argument in turn and assign it to a list element.
  566.     */
  567.    for (i = 1; i <= nargs; i++) {
  568.       if (DeRef(Arg(i)) == Error) 
  569.          RunErr(0, NULL);
  570.       bp->lslots[i-1] = Arg(i);
  571.       }
  572.    /*
  573.     * Point Arg0 at the new list and return it.
  574.     */
  575.    ArgType(0) = D_List;
  576.    Arg(0).vword.bptr = (union block *)hp;
  577.    Return;
  578.    }
  579.